CD Ware Multimedia 1995 May/cd Ware (Juegos) Epimundo.iso/DOS/PRGMMING/M2PROTOS.ZIP/QCKPACK.MOD

Modula Implementation | 1991-01-30 | 11.8 KB | 367 lines

(*# call(o_a_copy => off) *)
(*%F _fdata *)
(*# call(seg_name => null) *)
(*%E *)
(*# module(implementation=>on) *)
(*# data(seg_name => null) *)
IMPLEMENTATION MODULE QCkpack;

                     (* This JPI Modula-2 module is part of *)

                      (* QC -- a communications program *)
                             (* by Carl Neiburger *)
                              (* 169 N. 25th St.*)
                          (* San Jose, Calif. 95116 *)

                         (* CompuServe No. 72336,2257 *)

FROM QCcomm IMPORT (* CommOK, *) ComAbort, ComTimedOut, CommRdData,
     CommRdDataTest, CommWrData, soh;
FROM CRC IMPORT DoKCRC, DoCks;
FROM Lib IMPORT Move, Fill;
FROM QCdisp IMPORT DataRegisters, Packets, DisplayData;
FROM UTIL IMPORT SBITSET;

TYPE InitArrayType = ARRAY[1..SIZE(DefType)] OF SHORTCARD;

CONST
    MyDefs = DefType(
         (*  1 MaxLength *)     94,             (* even if long used *)
         (*  2 TimeOut *)       15,
         (*  3 NumPad *)         0,
         (*  4 PadChar *)       40C,
         (*  5 EolChar *)       15C,
         (*  6 CntrlQuote *)    CHR(CtlChar),  (* '#' *)
         (*  7 Bit8Quote *)     'Y',           (*  will do if requested *)
         (*  8 CheckType *)     '3',           (*  CRC *)
         (*  9 RepChar *)       '~',
         (* 10 Capas *)         CapasType{LongOK},
         (* 11 Windo *)         0,
         (* 12 HiMaxLen *)      MaxPacketSize DIV 95,
         (* 13 LoMaxLen *)      MaxPacketSize MOD 95);

    SixBits = SBITSET{0,1,2,3,4,5};
    SevenBits = SBITSET{0,1,2,3,4,5,6};
    EightBits = SBITSET{0,1,2,3,4,5,6,7};

VAR Parity    : SBITSET;
    InitArray : InitArrayType;  (* used to send MyDefs *)

PROCEDURE SimpleCheck(Sum: WORD): SHORTCARD;
BEGIN
  RETURN SHORTCARD(
    SBITSET( SHORTCARD(Sum) + SHORTCARD(Sum) >> 6 ) * SixBits ) + 20H
END SimpleCheck;

PROCEDURE SendPacket( Count : CARDINAL;     (* data characters *)
                      Seq   : SHORTCARD;    (* sequence number *)
                      PType : CHAR;
                      Data  : PackPtr);
 VAR
    i,
    Sum       : CARDINAL;
    CheckBytes,
    AChar     : SHORTCARD;

PROCEDURE SendAndCheck( c : BYTE );
BEGIN
    CommWrData(c);
    INC( Sum, CARDINAL(SBITSET(c) * Parity) );
    CRCchk := DoKCRC( ADR(c), 1, CRCchk  )
END SendAndCheck;

BEGIN
    SendCount := Count;
    SendSeq   := Seq;
    SendType  := PType;
    SendBuf   := Data;
    WHILE CommRdData( 0 ) < ComAbort DO END; (* flush *)
    Sum := 0;
    CRCchk := 0;
    CheckBytes := 1;
    IF NOT(SendType IN CHARSET{'G', 'I', 'R', 'S'}) AND
       NOT(RecvType IN CHARSET{'I', 'R', 'S'}) AND
       (TheirDefs.CheckType IN CHARSET{'2','3'}) THEN
         CheckBytes := SHORTCARD(TheirDefs.CheckType) - SHORTCARD('0')
    END;
    CommWrData( soh );
    IF SendCount > 94 THEN
         SendAndCheck(20H);  (* long packet format *)
    ELSE
         SendAndCheck( VAL(SHORTCARD, Count) + CheckBytes + 2 + 20H)
    END;
    SendAndCheck(Seq+20H);
    SendAndCheck(PType);
    IF SendCount > 94 THEN (* long packet format *)
         SendAndCheck(SHORTCARD((SendCount+ORD(CheckBytes)) DIV 95)+20H);
         SendAndCheck(SHORTCARD((SendCount+ORD(CheckBytes)) MOD 95)+20H);
         SendAndCheck( SimpleCheck(Sum) );
    END;
    IF SendCount > 0 THEN
         FOR i := 1 TO SendCount DO
              CommWrData(SendBuf^[i]);
         END;
         FOR i := 1 TO SendCount DO
              INC( Sum, CARDINAL(SBITSET(SendBuf^[i]) * Parity) );
         END;
         CRCchk := DoKCRC( SendBuf, SendCount, CRCchk );
    END; (* Send Data *)
    CASE CheckBytes OF
         1: CommWrData( SimpleCheck(Sum) );   (* Checksum + 20H *)
        |2: CommWrData( SHORTCARD((Sum >> 6) MOD 40H + 20H) );(*Bit 11-6*)
            CommWrData( SHORTCARD(Sum MOD 40H) + 20H);(*Bit5-0*)
        |3: CommWrData( SHORTCARD((CRCchk >> 12 ) MOD 10H) + 20H);
            CommWrData( SHORTCARD((CRCchk >> 6  ) MOD 40H) + 20H);
            CommWrData( SHORTCARD((CRCchk       ) MOD 40H) + 20H);
    END; (* CASE *)
    CommWrData(TheirDefs.EolChar); (* Cr *)
    FOR i := 1 TO ORD(TheirDefs.NumPad)  DO
         CommWrData(TheirDefs.PadChar);
    END;
    INC (DataRegisters[ FALSE, Packets ]);
    DisplayData ( Packets, FALSE );
END SendPacket;

PROCEDURE RecvPacket(): CHAR;
(* Sets RecvCount, RecvSeq and RecvType, and fills RecvBuf^ *)

 VAR
    i, Sum : CARDINAL;
    CheckBytes,
    Count,
    InChar : SHORTCARD;
    RecvOK : BOOLEAN;

PROCEDURE RdChar(VAR c: BYTE): BOOLEAN;
VAR dat : CARDINAL;
BEGIN
    dat := CommRdData( ORD(TheirDefs.TimeOut) );
    CASE dat OF
    ComAbort: WHILE CommRdData( 0 ) < ComAbort DO END; (* flush *)
            RecvType := '@';
|ComTimedOut: RecvType := 'T'
           ELSE c := VAL(BYTE, dat);
                RETURN TRUE
    END;
    RETURN FALSE
END RdChar;

PROCEDURE ReceiveAndCheck( VAR c: BYTE ): BOOLEAN;
BEGIN
    IF NOT RdChar( c ) THEN
         RETURN FALSE;
    END;
    INC( Sum, CARDINAL( SBITSET(c) * Parity) );
    Sum := Sum MOD 4096;
    CRCchk := DoKCRC( ADR(c), 1 , CRCchk );
    RETURN TRUE
END ReceiveAndCheck;

BEGIN
    i := 0;
    LOOP
        CASE CommRdDataTest( ORD(TheirDefs.TimeOut) ) OF
             soh: EXIT;
       |ComAbort: WHILE CommRdData( 0 ) < ComAbort DO END; (* flush *)
                  RecvType := '@';
                  RETURN '@';
    |ComTimedOut: RecvType := 'T';
                  RETURN 'T';
         END;
         INC(i);
         IF i >= PacketSize THEN
              RecvType := 'T';
              RETURN 'T'
         END
    END;

    Sum := 0;
    CRCchk := 0;

    IF NOT ReceiveAndCheck( Count ) THEN
         RETURN RecvType
    END;
    DEC( Count, 20H );
    IF NOT ReceiveAndCheck( RecvSeq ) THEN
         RETURN RecvType
    END;
    DEC( RecvSeq, 20H );
    IF NOT ReceiveAndCheck( RecvType ) THEN
         RETURN RecvType
    END;

    CheckBytes := 1;
    IF NOT (SendType IN CHARSET{'G', 'I', 'R', 'S'}) AND
       NOT( RecvType IN CHARSET{'R', 'S'})
       AND (CHR(TheirDefs.CheckType) IN CHARSET{'2','3'}) THEN
         CheckBytes := SHORTCARD(TheirDefs.CheckType) - SHORTCARD('0')
    END;
    IF Count = 0 THEN  (* Long Packet format *)
         IF NOT ReceiveAndCheck( LENX1 ) THEN
              RETURN RecvType
         END;
         DEC( LENX1, 20H );
         IF NOT ReceiveAndCheck( LENX2) THEN
              RETURN RecvType
         END;
         DEC( LENX2, 20H );
         IF ( NOT RdChar(HCHECK) ) THEN
              RETURN RecvType
         END;
         IF HCHECK <> SimpleCheck(Sum) THEN
              WHILE RdChar(HCHECK) DO END; (*Flush*)
              RETURN RecvType
         END;
         INC( Sum, ORD(HCHECK) );
         IF CheckBytes = 3 THEN
              CRCchk := DoKCRC( ADR(HCHECK), 1, CRCchk )
         END;
         RecvCount := (95* ORD(LENX1) ) + ORD(LENX2 - CheckBytes);
    ELSE (* NOT Long Packet format *)
         RecvCount := ORD(Count - 2 - CheckBytes);
    END;
    IF RecvCount >  0 THEN
         FOR i := 1 TO RecvCount  DO (* Recv Data *)
              IF NOT RdChar( RecvBuf^[i] ) THEN
                   RETURN RecvType;
              END;
         END;
         FOR i := 1 TO RecvCount  DO
              INC( Sum, CARDINAL(SBITSET(RecvBuf^[i]) * Parity) );
         END;
         Sum := Sum MOD 4096;
         CRCchk := DoKCRC( RecvBuf, RecvCount, CRCchk );
    END; (* Revc Data *)
    CASE CheckBytes OF
         1: RecvOK := RdChar(InChar) AND (InChar = SimpleCheck(Sum));
        |2: RecvOK := RdChar(InChar) AND
              (InChar - 20H = SHORTCARD(Sum >> 6) MOD 40H) (*Bit 11-6*)
              AND RdChar(InChar) AND
              (InChar - 20H = SHORTCARD( Sum MOD 40H) );  (*Bit5-0*)
        |3: RecvOK := RdChar(InChar)
              AND (InChar = SHORTCARD((CRCchk >> 12 ) MOD 10H) + 20H)
              AND RdChar(InChar)
              AND (InChar = SHORTCARD((CRCchk >> 6  ) MOD 40H) + 20H)
              AND RdChar(InChar)
              AND (InChar = SHORTCARD((CRCchk       ) MOD 40H) + 20H);
    END;  (* CASE CRC OR Checksum *)
    INC (DataRegisters[ TRUE, Packets ]);
    DisplayData ( Packets, TRUE );
    IF RecvOK THEN
         RETURN RecvType
    ELSE
         RETURN 'Q'
    END
END RecvPacket;

PROCEDURE SendPacketType  (PacketType : BYTE);
BEGIN (* Send ACK or NAK or B or Z *)
    SendPacket( 0, (SendSeq+1) MOD 64, PacketType, NIL );
END SendPacketType; (* Send ACK or NAK or B or Z *)

PROCEDURE SendDefaults( typ : CHAR );
VAR i : CARDINAL;
BEGIN
    InitArray := InitArrayType(MyDefs);
    IF typ <> 'Y' THEN
         TheirDefs := MyDefs
    ELSIF TheirDefs.RepChar <> ' ' THEN
         INCL(MyExtControls, TheirDefs.RepChar);
         INCL(MyExtControls, CHR(SHORTCARD(TheirDefs.RepChar)+80H));
         InitArray[9] := SHORTCARD(TheirDefs.RepChar)
              (* Accept their repeat char *)
    END;
    FOR i := 1 TO 5 DO
         INC(InitArray[i], 20H);
    END;
    FOR i := 10 TO SIZE(InitArray) DO
         INC(InitArray[i], 20H);
    END;
    SendPacket( SIZE(InitArray), 0, typ, ADR(InitArray) );
END SendDefaults;

PROCEDURE GetDefinitions;
VAR i, j : CARDINAL; Capas : CapasType;
BEGIN
    i := RecvCount;
    IF i > 5 THEN
         i := 5
    END;
    FOR j := 1 TO i DO
         DEC(RecvBuf^[j], 20H)
    END;
    IF RecvCount > 5 THEN
         INC(i)
    END;
    Move ( RecvBuf, ADR(TheirDefs), i );
    MyExtControls := CHARSET{CHR(CtlChar), CHR(CtlChar+80H)};
    Fill(ADR(TheirDefs.Bit8Quote), 3, 40C);
         (* Fill with spaces Bit8Quote, CheckType, RepChar *)
    IF (RecvCount >= 7) AND
      (CHR(RecvBuf^[7]) IN CHARSET{'!'..'?','`'..'~'}) THEN
         TheirDefs.Bit8Quote := CHR(RecvBuf^[7]);
         INCL(MyExtControls, TheirDefs.Bit8Quote );
         INCL(MyExtControls, CHR(SHORTCARD(TheirDefs.Bit8Quote)+80H));
         Parity := SevenBits;
    ELSE
         Parity := EightBits;
    END;
    IF (RecvCount >= 8) AND (CHR(RecvBuf^[8]) IN CHARSET{'1'..'3'} ) THEN
         IF CHR(RecvBuf^[8]) < MyDefs.CheckType THEN
              TheirDefs.CheckType  := CHR(RecvBuf^[8])
         ELSE
              TheirDefs.CheckType  := MyDefs.CheckType
         END
    ELSE
         TheirDefs.CheckType  := '1'
    END;
    IF RecvCount >= 9 THEN
         IF (RecvType = 'Y') THEN
              IF CHR(RecvBuf^[9]) = MyDefs.RepChar THEN
                   TheirDefs.RepChar := MyDefs.RepChar;
                   INCL(MyExtControls, TheirDefs.RepChar);
                   INCL(MyExtControls, CHR(SHORTCARD(TheirDefs.RepChar)+80H));
              END
         ELSIF CHR(RecvBuf^[9]) IN CHARSET{'!'..'?','`'..'~'} THEN
              TheirDefs.RepChar := CHR(RecvBuf^[9]);
         END
    END;
    IF RecvCount >= 10 THEN
         FOR j := 10 TO RecvCount DO
              DEC(RecvBuf^[j], 20H)
         END;
         i := 10;
         Capas := CapasType (RecvBuf^[10] )
    ELSE
         Capas := CapasType {}
    END;
    IF i = 10 THEN       (* discard unknown Capas bytes *)
         WHILE ODD(RecvBuf^[i])
              DO INC(i)
         END;
         INC(i, 2);      (* skip last Capas, Windo bytes *)
         IF (LongOK IN Capas) AND (RecvCount >= i+1) THEN
              PacketSize := (ORD(RecvBuf^[i])-20H)*95
                   + ORD(RecvBuf^[i+1])-20H;
              IF PacketSize > MaxPacketSize THEN
                   PacketSize := MaxPacketSize
              END;
         ELSE
              PacketSize := ORD(TheirDefs.MaxLength)
         END
    ELSE
         PacketSize := ORD(TheirDefs.MaxLength)
    END;
END GetDefinitions;

PROCEDURE InitDefinitions;
BEGIN
    PacketSize := 94; (*MaxPacketSize *)
    TheirDefs := MyDefs;
    Parity := EightBits;
END InitDefinitions;

BEGIN
    InitDefinitions;
END QCkpack.